Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue50/Except/LIGen.dpr

Text File | 1999-09-06 | 19.2 KB | 653 lines

program LIGen;

{$APPTYPE CONSOLE}

uses SysUtils, Registry, LIUtils, Windows;

type
  TCompileStatus = (csNone, csCompile, csMake, csBuild);

var
  ExtraCmdLine:  String = '';
  ProjectName:   String = '';
  OutputDir:     String = '';
  DCC32ExecName: String = 'DCC32.EXE';
  OptFileName:   String;
  MapFileName:   String;
  CfgFileName:   String;
  UseDCCVer:     String;
  CompileStatus: TCompileStatus = csNone;
  OverwriteCfg:  Boolean = False;
  PauseOnError:  Boolean = False;
  DCC32CfgOnly:  Boolean = False;
  DontGenerateDCC32Cfg: Boolean = False;
  CfgFile:       TextFile;
  UnitTable:     TGrowingArray;
  PublicList:    TGrowingArray;
  LineNumbers:   TGrowingArray;
  Resource:      TGrowingArray;
  RTLIHeader:    TRTLIHeader;

// Displays command line syntax and terminates

procedure DisplaySyntax;
begin
  WriteLn('Syntax: LIGen [Options] ProjectFile');
  WriteLn('/N           create DCC32.CFG only, do Not compile and generate RTLI');
  WriteLn('/O           Overwrite DCC32.CFG');
  WriteLn('/P           Pause on error: wait for the Enter key to be pressed');
  WriteLn('/Rb,/Rc,/Rm  Run DCC32 only: Rb=build, Rc=compile, Rm=make project');
  WriteLn('/S<x>        pass command line Switch -<x> directly to DCC32');
  WriteLn('/V<X.0>      Use DCC32 for version X.0 of Delphi');
  WriteLn('/?,/H        display this Help screen');
  Halt(1);
end;

// Displays an error message and terminates

procedure Error(const ErrStr: String; const Params: array of const);
begin
  WriteLn('**Error**  ', Format(ErrStr, Params));
  if PauseOnError then
  begin
    WriteLn('Press Enter to exit');
    ReadLn;
  end;
  Halt(2);
end;

// Reports an invalid command line option error

procedure InvalidCmdLineOption(const ParmStr: String);
begin
  Error('Invalid command line option "%s"', [ParmStr]);
end;

// Reports an unsuccessful compilation

procedure CompilationFailed(ExitCode: Integer);
begin
  Error('Compilation failed, return code = %d', [ExitCode]);
end;

// Parses the supplied command line

procedure ParseCmdLine;
var
  ParmIndex: Integer;
  ParmStr: String;
begin
  ParmIndex := 1;
  ParmStr := '';
  repeat
    ParmStr := ParamStr(ParmIndex);
    Inc(ParmIndex);
    if ParamCount = 0 then ParmStr := '/?';
    if (ParmStr <> '') then
    begin
      if not (ParmStr[1] in ['-', '/']) then
        ProjectName := ExpandFileName(ParmStr)
      else
        case Length(ParmStr) of
          2:
            case UpCase(ParmStr[2]) of
              'D': DontGenerateDCC32Cfg := True;
              'N': DCC32CfgOnly  := True;
              'O': OverwriteCfg := True;
              'P': PauseOnError := True;
              '?','H': DisplaySyntax;
              else InvalidCmdLineOption(ParmStr);
            end;
          3..1024:
            case UpCase(ParmStr[2]) of
              'S':
                begin
                  if ExtraCmdLine <> '' then
                    ExtraCmdLine := ExtraCmdLine + ' ';
                  ExtraCmdLine := ExtraCmdLine + '-' + Copy(ParmStr, 3, MaxInt);
                end;
              'V':
                begin
                  UseDCCVer := Copy(ParmStr, 3, 3);
                end;
              'R':
                begin
                  if (Length(ParmStr) <> 3) or not (UpCase(ParmStr[3]) in ['B','C','M']) then
                    InvalidCmdLineOption(ParmStr);
                  case UpCase(ParmStr[3]) of
                    'B': CompileStatus := csBuild;
                    'C': CompileStatus := csCompile;
                    'M': CompileStatus := csMake;
                  end;
                end;
              else InvalidCmdLineOption(ParmStr);
            end;
        end;
    end;
  until ParmStr = '';
  if ProjectName = '' then
    DisplaySyntax;
end;

// The following three functions are similar to the corresponding Dos unit
// functions found in Borland Pascal. Unfortunately, Dos unit disappeared
// in Delphi and there are no equivalent functions in the SysUtils unit.
// So we have to implement them here.

var
  ProcessInfo: TProcessInformation;

function Exec(const Path,CmdLine: String): Integer;
var
  Win32Path: String;
  Win32CmdLine: String;
  StartupInfo: TStartupInfo;
begin
  Win32Path := ExpandFileName(Path);
  if Win32Path <> '' then
    if Win32Path[1] <> '"' then
      Win32Path := '"' + Win32Path + '"';
  Win32CmdLine := Win32Path + ' ' + CmdLine;
  FillChar(StartupInfo, SizeOf(TStartupInfo), 0);
  with StartupInfo do
  begin
    cb := SizeOf(TStartupInfo);
    dwFlags := startf_UseShowWindow;
    wShowWindow := sw_ShowNormal;
  end;
  if CreateProcess(nil, PChar(Win32CmdLine), nil, nil, True, normal_Priority_Class, nil, nil, StartupInfo, ProcessInfo) then
    begin
      WaitForSingleObject(ProcessInfo.hProcess, Infinite);
      Result := 0;
    end
  else
    Result := GetLastError;
end;

function DosExitCode: DWord;
begin
  GetExitCodeProcess(ProcessInfo.hProcess, Result);
end;

function GetEnv(const EnvVar: String): String;
var
  Buffer: array[0..1023] of Char;
begin
  SetString(Result, Buffer,
    GetEnvironmentVariable(PChar(EnvVar), Buffer, SizeOf(Buffer)));
end;

// Reads an integer value from the INI file

function OptReadInteger(const AppName,KeyName: String; Default: Integer): Integer;
begin
  Result := GetPrivateProfileInt(PChar(AppName), PChar(KeyName), Default,
    PChar(OptFileName));
end;

// Reads a string value from the INI file

function OptReadString(const AppName,KeyName,Default: String): String;
var
  Buffer: array[0..259] of Char;
begin
  GetPrivateProfileString(PChar(AppName), PChar(KeyName), PChar(Default),
    Buffer, SizeOf(Buffer), PChar(OptFileName));
  Result := Buffer;
end;

procedure AppendToCmdLine(const S: String);
var
  C: Char;
begin
  if S = '(' then
    begin
      CfgFileName := ExtractFilePath(OptFileName) + '\DCC32.CFG';
      C := 'Y';
      if FileExists(CfgFileName) then
      begin
        if not OverwriteCfg then
        begin
          Write('File DCC32.CFG already exists. Overwrite? (Y/N)');
          repeat
            ReadLn(C);
          until C in ['Y', 'N', 'y', 'n'];
        end;
      end;
      if UpCase(C) = 'N' then
        Halt(3);
      AssignFile(CfgFile, CfgFileName);
      Rewrite(CfgFile);
      if IOResult <> 0 then
        Error('Cannot create CFG file "%s"', [CfgFileName]);
    end
  else
    if S = ')' then
      begin
        CloseFile(CfgFile);
        IOResult; //  := 0;
      end
    else
      begin
        WriteLn(CfgFile, S);
        if IOResult <> 0 then
          Error('Error writing file "%s" - %s', [CfgFileName, SysErrorMessage(IOResult)]);
      end;
end;

// Forms the command line compiler configuration file based on the settings
// found in the project option file

procedure FormDCC32Config;
var
  C,State: Char;
  Value: Integer;
  CfgStr: String;
begin
  OptFileName := ChangeFileExt(ProjectName, '.DOF');
  if not FileExists(OptFileName) then
    Error('Cannot find project option file "%s"', [OptFileName]);
  CfgStr := '';
  for C := 'A' to 'Z' do
  begin
    Value := OptReadInteger('Compiler', C, 2);
    case Value of
      0: State := '-';
      1: State := '+';
      else
        if C = 'A' then
          Error('Invalid Delphi options file "%s"', [OptFileName]);
        State := '-';
    end;
    CfgStr := Format('%s-$%s%s ', [CfgStr, C, State]);
  end;
  AppendToCmdLine('(');
  AppendToCmdLine(CfgStr);
  case CompileStatus of
    csMake:  AppendToCmdLine('-M');
    csBuild: AppendToCmdLine('-B');
  end;
  if OptReadInteger('Compiler', 'ShowHints', 2) = 1 then
    AppendToCmdLine('-H');
  if OptReadInteger('Compiler', 'ShowWarnings', 2) = 1 then
    AppendToCmdLine('-W');
  CfgStr := OptReadString('Compiler', 'UnitAliases', '');
  if CfgStr <> '' then
    AppendToCmdLine('-A' + CfgStr);
  OutputDir := OptReadString('Directories', 'OutputDir', '');
  if OutputDir <> '' then
    AppendToCmdLine('-E"' + OutputDir + '"');
  CfgStr := OptReadString('Directories', 'SearchPath', '');
  if CfgStr <> '' then
  begin
    AppendToCmdLine('-U"' + CfgStr + '"');
    AppendToCmdLine('-I"' + CfgStr + '"');
    AppendToCmdLine('-R"' + CfgStr + '"');
    AppendToCmdLine('-O"' + CfgStr + '"');
  end;
  CfgStr := OptReadString('Directories', 'Conditionals', '');
  if CfgStr <> '' then
    AppendToCmdLine('-D' + CfgStr);
  C := #0;
  case OptReadInteger('Linker', 'MapFile', 0) of
    1: C := 'S';
    2: C := 'P';
    3: C := 'D';
  end;
  if C <> #0 then
    AppendToCmdLine('-G' + C);
  if OptReadInteger('Linker', 'OutputObjs', 0) <> 0 then
    AppendToCmdLine('-J');
  C := 'C';
  if OptReadInteger('Linker', 'ConsoleApp', 0) = 1 then
    C := 'G';
  AppendToCmdLine('-C' + C);
  if OptReadInteger('Linker', 'DebugInfo', 0) <> 0 then
    AppendToCmdLine('-V');
  AppendToCmdLine(Format('-M%d,%d',
    [OptReadInteger('Linker', 'MinStackSize', 16384),
     OptReadInteger('Linker', 'MaxStackSize', 1048576)]));
  AppendToCmdLine(Format('-K%x', [OptReadInteger('Linker', 'ImageBase', $400000)]));
  AppendToCmdLine(')');
end;


// Runs the command line compiler
function CompileProject(const CtrlParam: String): Integer;
var
  ErrCode: Integer;
  DCCName: String;
  Registry: TRegistry;

  function HasPathForVersion(const Version: string): boolean;
  begin
    Result := Registry.OpenKey('\SOFTWARE\Borland\Delphi\'+Version, False);
    if Result then
    begin
      DCCName := Registry.ReadString('RootDir');
      if DCCName <> '' then
        DCCName := DCCName + '\BIN\DCC32.EXE';
    end;
  end;

begin
  Registry := TRegistry.Create;
  Registry.RootKey := hkey_Local_Machine;
  try
    // Has the user specificed the compiler version?
    if UseDCCVer <> '' then
      HasPathForVersion(UseDCCVer)
    else
    begin
      // Try to find the command line compiler executable
      DCCName := FileSearch(DCC32ExecName, GetEnv('PATH'));
      if DCCName <> '' then
        DCCName := ExpandFileName(DCCName)
      else
      begin
        // Executable is not found in 'PATH'. Try to find the Delphi directory
        // setting RootDir in the Registry under
        // HKEY_LOCAL_MACHINE\SOFTWARE\Borland\Delphi\X.0
        if HasPathForVersion('5.0') or
           HasPathForVersion('4.0') or
           HasPathForVersion('3.0') or
           HasPathForVersion('2.0') then
          ;
      end;
    end;
  finally
    Registry.Destroy; // Hmm, looks a bit severe :-)
  end;
  if DCCName = '' then
    Error('Cannot find file %s, make sure it is included in PATH, or use the /V option', [DCC32ExecName]);
  // Change to the directory where the project is located
  SetCurrentDir(ExtractFilePath(OptFileName));
  // Run the command line compiler
  ErrCode := Exec(DCCName, ChangeFileExt(ProjectName, '.DPR') + ' ' + ExtraCmdLine + CtrlParam);
  if ErrCode <> 0 then
    Error('Cannot execute %s - %s', [DCCName, SysErrorMessage(ErrCode)]);
  Result := DosExitCode;
end;

// Figures out the name of the .MAP file

procedure GetMapFileName;
begin
  if OutputDir = '' then
    MapFileName := ProjectName
  else
    begin
      MapFileName := ExtractFileName(ProjectName);
      if OutputDir[Length(OutputDir)] <> '\' then
        MapFileName := OutputDir + '\' + MapFileName
      else
        MapFileName := OutputDir + MapFileName;
    end;
  MapFileName := ChangeFileExt(MapFileName, '.MAP');
end;

// Parses a map file

procedure ParseMapFile;
var
  C: Char;
  I,MapLineNo,SegNo,LnNo,LnOfs,LastLnNo,LastOfs,CurOfs,CodeEnd: Integer;
  Buffer: array[0..299] of Char;
  S,Name,SrcName: String;
  MapFile: Text;

procedure InvalidMapFile;
begin
  Error('Invalid format of the map file "%s" at line %d', [MapFileName, MapLineNo]);
end;

procedure ReadMapLine;
begin
  ReadLn(MapFile, S);
  Inc(MapLineNo);
  if IOResult <> 0 then
    Error('Error reading map file "%s" - %s', [MapFileName, SysErrorMessage(IOResult)]);
end;

procedure WriteData(const A: TGrowingArray; Size: Integer);
begin
  Move(Buffer, A.Allocate(Size)^, Size);
end;

begin
  UnitTable   := TGrowingArray.Create(512, 512, 1);
  PublicList  := TGrowingArray.Create(8*1024, 8*1024, 1);
  LineNumbers := TGrowingArray.Create(8*1024, 8*1024, 1);
  Resource    := TGrowingArray.Create(16*1024, 16*1024, 1);
  FillChar(RTLIHeader, SizeOf(RTLIHeader), 0);
  Assign(MapFile, MapFileName);
  Reset(MapFile);
  if IOResult <> 0 then
    Error('Cannot open file "%s" - %s', [MapFileName, SysErrorMessage(IOResult)]);
  // Parse detailed segment map, for example:
  // 0001:00000000 00000B90 C=CODE     S=.text    G=(none)   M=System   ACBP=A9
  // 0001:00000B90 00000019 C=CODE     S=.text    G=(none)   M=PROGRAM  ACBP=A9
  MapLineNo := 0;
  while not EOF(MapFile) do
  begin
    ReadMapLine;
    if S = 'Detailed map of segments' then
      Break;
  end;
  if EOF(MapFile) then
    InvalidMapFile;
  ReadMapLine;
  CodeEnd := 0;
  repeat
    ReadMapLine;
    if S <> '' then
    begin
      I := 1;
      SkipBlanks(S, I);
      SegNo := ParseHex(S, I);
      if SegNo > 1 then
        Break;
      C := ParseChr(S, I);
      CurOfs := ParseHex(S, I);
      SkipBlanks(S, I);
      CodeEnd := ParseHex(S, I) + CurOfs;
      I := Pos('M=', S);
      Name := '';
      if I > 0 then
      begin
        Inc(I, 2);
        Name := ParseStr(S, I);
      end;
      if (C <> ':') or (SegNo = -1) or (CurOfs = -1) or (Name = '') then
        InvalidMapFile;
      PDWord(@Buffer)^ := CurOfs;
      WriteData(UnitTable, SizeOf(DWord));
      WriteData(UnitTable, EncodeString(Name, Buffer));
      Inc(RTLIHeader.rtliUnitCount);
    end;
  until S = '';
  // Ending code offset
  PDWord(@Buffer)^ := CodeEnd;
  WriteData(UnitTable, SizeOf(DWord));
  // Parse public table, for example
  // 0001:00000000       TextStart
  // 0001:00000234       @HandleFinally
  // 0001:0000026C       @SafeCall
  while not EOF(MapFile) do
  begin
    ReadMapLine;
    if Pos('Publics by Value', S) <> 0 then
    begin
      ReadMapLine;
      Break;
    end;
  end;
  LastOfs := 0;
  if EOF(MapFile) then
    InvalidMapFile;
  repeat
    ReadMapLine;
    I := 1;
    SkipBlanks(S, I);
    SegNo := ParseHex(S, I);
    if SegNo = 1 then
    begin
      C := ParseChr(S, I);
      CurOfs := ParseHex(S, I);
      SkipBlanks(S, I);
      Name := ParseStr(S, I);
      if (C <> ':') or (CurOfs = -1) or (Name = '') then
        InvalidMapFile;
      WriteData(PublicList, EncodeString(Name, Buffer));
      WriteData(PublicList, EncodeSymbolOfs(Buffer, CurOfs - LastOfs));
{      if Name = '___Fixup___' then
        RTLIHeader.rtliFixup := CurOfs;}
      Inc(RTLIHeader.rtliPublicCount);
      LastOfs := CurOfs;
    end;
  until S = '';
  // Terminating entry
  Buffer[0] := #0;
  WriteData(PublicList, 1);
  WriteData(PublicList, EncodeSymbolOfs(Buffer, CodeEnd - LastOfs));
  // Parse line number information, for example
  // Line numbers for MyProg(myprog.pas) segment .text
  //
  //   1 0001:00000B90     2 0001:00000BA0
  while not EOF(MapFile) do
  begin
    ReadMapLine;
    I := Pos('Line numbers for', S);
    if I <> 0 then
    begin
      Inc(I, 16);
      SkipBlanks(S, I);
      Name := ParseStr(S, I);
      C := ParseChr(S, I);
      SrcName := ParseStr(S, I);
      if (Name = '') or (SrcName = '') or (C <> '(') then
        InvalidMapFile;
      Name := SrcName;
      Buffer[0] := Chr(escFileName);
      WriteData(LineNumbers, EncodeString(Name, @Buffer[1]) + 1);
      ReadMapLine; // Skip blank line
      ReadMapLine;
      LastOfs := 0;
      LastLnNo := 0;
      repeat
        I := 1;
        repeat
          SkipBlanks(S, I);
          LnNo := ParseDec(S, I);
          SkipBlanks(S, I);
          SegNo := ParseHex(S, I);
          C     := ParseChr(S, I);
          LnOfs := ParseHex(S, I);
          if (SegNo <> 1) or (C <> ':') or (LnOfs = -1) then
            InvalidMapFile;
          WriteData(LineNumbers, EncodeLineNumber(Buffer, LnNo - LastLnNo, LnOfs - LastOfs));
          LastLnNo := LnNo;
          LastOfs := LnOfs;
          Inc(RTLIHeader.rtliLineCount);
          SkipBlanks(S, I);
        until I > Length(S);
        ReadMapLine;
      until S = '';
    end;
  end;
  CloseFile(MapFile);
  IOResult; // := 0;
//  if RTLIHeader.rtliFixup = 0 then
//    Error('RTLI is not used in the project %s', [ProjectName]);
end;

procedure FormResourceFile;
const
  Signature: array[0..31] of Byte =
    ($00,$00,$00,$00,$20,$00,$00,$00,$FF,$FF,$00,$00,$FF,$FF,$00,$00,
     $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00);
   ResHdr: array [0..31] of Byte =
     ($00,$00,$00,$00,$20,$00,$00,$00,$FF,$FF,$0A,$00,$FF,$FF,$77,$77,
      $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00);
   PadBytes: array[0..2] of Byte = (0, 0, 0);
var
  ResSizeOfs: Integer;

procedure WriteToResource(const Buffer; Size: Integer);
begin
  Move(Buffer, Resource.Allocate(Size)^, Size);
end;

begin
  // Record identifing the resource file as a file containing 32-bit resources
  WriteToResource(Signature, SizeOf(Signature));
  // Resource header
  ResSizeOfs := Resource.Count;
  WriteToResource(ResHdr, SizeOf(ResHdr));
  // Resource itself:
  // RTLI Header
  WriteToResource(RTLIHeader, SizeOf(RTLIHeader));
  //  - Unit table
  WriteToResource(UnitTable.ArrPtr^, UnitTable.Count);
  UnitTable.Destroy;
  //  - Public Table
  WriteToResource(PublicList.ArrPtr^, PublicList.Count);
  PublicList.Destroy;
  //  - Line number information
  WriteToResource(LineNumbers.ArrPtr^, LineNumbers.Count);
  LineNumbers.Destroy;
  // Align resource at DWord boundary
  if (Resource.Count and $3) <> 0 then
    WriteToResource(PadBytes, 4 - (Resource.Count and $3));
  PDWord(PChar(Resource.ArrPtr) + ResSizeOfs)^ := Resource.Count - ResSizeOfs - SizeOf(ResHdr);
end;

procedure StoreResourceFile;
var
  ResFileName: AnsiString;
  ResFile: file;
begin
  ResFileName := ChangeFileExt(ProjectName, '.RLI');
  Assign(ResFile, ResFileName);
  Rewrite(ResFile, 1);
  if IOResult <> 0 then
    Error('Cannot create file "%s" - %s', [ResFileName, SysErrorMessage(IOResult)]);
  BlockWrite(ResFile, Resource.ArrPtr^, Resource.Count);
  if IOResult <> 0 then
    Error('Error writing file "%s" - %s', [ResFileName, SysErrorMessage(IOResult)]);
  Close(ResFile);
  IOResult; // := 0;
  Resource.Destroy;
end;

var
  ExitCode: Integer;

begin
  WriteLn('RTLI Generator/DCC32 launcher for Delphi2  Version 1.0');
  ParseCmdLine;
  if not DontGenerateDCC32Cfg then
    FormDCC32Config;
  if not DCC32CfgOnly then
  begin
    if CompileStatus <> csNone then
      // Terminate itself passing the exit code from the compiler.
      // This ensures that MAKE process fails if the compilation is unsuccessful
      Halt(CompileProject(''))
    else
      begin
        CompileStatus := csMake;
        ExitCode := CompileProject(' -GD -M');
        if ExitCode <> 0 then
          CompilationFailed(ExitCode);
        GetMapFileName;
        ParseMapFile;
        FormResourceFile;
        StoreResourceFile;
        ExitCode := CompileProject(' -DBindingRTLI');
        if ExitCode <> 0 then
          CompilationFailed(ExitCode);
      end;
  end;
end.